\(E(peso) = \beta_0 + \beta_1 * altura + \beta_2 * edad + \beta_3 * genero + \beta4 * diasActividadFisicaSemanal + \beta5 * consumoDiarioAlcohol\)
Primero se cargan las librerías necesarias:
options(warn=-1)
rm(list=ls())
gc()
used (Mb) gc trigger (Mb) max used (Mb)
Ncells 3056917 163.3 5545042 296.2 5545042 296.2
Vcells 7073314 54.0 17830652 136.1 17830652 136.1
options(warn=-2)
# install.packages("pacman") -- Descomentar par instalar pacman
library(pacman)
p_load_gh('adrianmarino/commons')
import('../src/dataset.R')
[1] "-> '../src/dataset.R' script loadded successfuly!"
import('../src/preprocessing.R')
[1] "-> '../src/preprocessing.R' script loadded successfuly!"
import('../src/model.R')
[1] "-> '../src/model.R' script loadded successfuly!"
import('../src/plot.R')
[1] "-> '../src/plot.R' script loadded successfuly!"
A continuación se carga los conjuntos de entrenamiento y test. también se resumen los valores de las variables categóricas y se excluyen las observaciones con valores faltantes, ya que son muy pocas con respecto al total.
train_set <- load_train_set() %>%
preprocess() %>%
shorten_values() %>%
process_missings()
test_set <- load_test_set() %>%
preprocess() %>%
shorten_values() %>%
process_missings()
glimpse(train_set)
Rows: 7,024
Columns: 15
$ edad <int> 17, 15, 15, 16, 17, 15, 13, 17, 17, 16, 16, 14, 15, 17, 15, 14, 15, 17, 17, 16, 14, 12, …
$ genero <fct> Femenino, Masculino, Masculino, Masculino, Masculino, Masculino, Femenino, Femenino, Mas…
$ nivel_educativo <ord> 2, 1, 2, 1, 2, 1, 9, 9, 1, 3, 3, 8, 9, 3, 9, 2, 2, 3, 3, 2, 9, 8, 2, 3, 2, 2, 3, 1, 2, 1…
$ altura <int> 165, 178, 172, 170, 170, 178, 156, 163, 164, 167, 185, 146, 180, 175, 183, 165, 165, 157…
$ peso <int> 62, 62, 62, 65, 75, 88, 46, 60, 57, 51, 100, 33, 62, 70, 80, 60, 47, 50, 50, 70, 75, 55,…
$ frecuencia_hambre_mensual <ord> Rara vez, Rara vez, Nunca, Nunca, Rara vez, Nunca, Nunca, Nunca, Nunca, Nunca, Nunca, Ra…
$ dias_consumo_comida_rapida <int> 0, 0, 3, 1, 1, 2, 0, 0, 0, 3, 4, 2, 1, 1, 3, 0, 0, 0, 0, 1, 0, 6, 0, 1, 0, 2, 0, 2, 0, 0…
$ edad_consumo_alcohol <ord> 14-15, <=7, 0, 14-15, 16-17, 8-9, 10-11, 16-17, <=7, 0, 12-13, 12-13, 0, 14-15, <=7, 14-…
$ consumo_diario_alcohol <dbl> 5.0, 4.0, 0.0, 0.0, 0.0, 5.0, 1.0, 0.5, 5.0, 0.0, 5.0, 0.0, 0.0, 2.0, 1.0, 0.0, 5.0, 0.0…
$ dias_actividad_fisica_semanal <int> 7, 7, 7, 7, 0, 7, 0, 2, 7, 3, 2, 2, 7, 1, 4, 0, 1, 6, 5, 7, 3, 0, 7, 5, 2, 2, 4, 2, 7, 4…
$ consumo_semanal_frutas <ord> 0, 0, 0, 4-6, 14, 7, 14, 21, 0, 14, <=3, <=3, 7, <=3, <=3, <=3, 0, <=3, <=3, 14, <=3, 4-…
$ consumo_semanal_verdura <ord> 4-6, 4-6, 7, >=28, <=3, 14, 4-6, 7, 0, 4-6, <=3, 7, 7, <=3, 4-6, <=3, <=3, <=3, 4-6, <=3…
$ consumo_semanal_gaseosas <ord> <=3, <=3, 4-6, <=3, 7, 4-6, 0, 7, <=3, 4-6, 4-6, <=3, <=3, 4-6, 4-6, <=3, 0, 0, 0, 7, <=…
$ consumo_semanal_snacks <ord> <=3, 0, 4-6, <=3, 0, 4-6, 0, <=3, 0, <=3, <=3, 0, <=3, 7, <=3, 0, NA, <=3, <=3, <=3, <=3…
$ consumo_semanal_comida_grasa <ord> 0, 4-6, 0, 0, <=3, 4-6, <=3, 7, 0, <=3, 0, <=3, 0, 7, 0, 4-6, 4-6, 0, <=3, <=3, <=3, <=3…
Se fija la semilla y se validan las proporciones de los conjuntos de entrenamiento y test:
set.seed(25)
show_train_test_props(train_set, test_set)
[1] "Train: 70%, Test: 30%"
Modelo 1
Se plantea el primer modelo lineal:
model_1 <- lm(
peso ~ altura + edad + genero + dias_actividad_fisica_semanal + consumo_diario_alcohol,
data = train_set
)
Veamos a continuación un resumen de los coeficiente del modelo 1:
coefficients_summary(model_1)
_________________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
=========================================================================================================
(Intercept) -68.922688070 2.33805445 -29.4786497 3.614866e-180 -73.5059810 -64.33939510
altura 0.650606544 0.01437975 45.2446353 0.000000e+00 0.6224179 0.67879520
edad 1.406727060 0.09385081 14.9889709 5.121599e-50 1.2227511 1.59070300
generoMasculino 1.262643558 0.27282821 4.6279802 3.758831e-06 0.7278179 1.79746926
dias_actividad_fisica_semanal -0.087391031 0.04992917 -1.7503000 8.011025e-02 -0.1852673 0.01048523
consumo_diario_alcohol 0.007271379 0.06138558 0.1184542 9.057112e-01 -0.1130629 0.12760566
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
____________________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
============================================================================
(Intercept) -68.922688070 Si No
altura 0.650606544 Si No
edad 1.406727060 Si No
generoMasculino 1.262643558 Si No
dias_actividad_fisica_semanal -0.087391031 No Si
consumo_diario_alcohol 0.007271379 No Si
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Al analizar cada coeficiente se encuentra que:
\(\hat{\beta_0}\) (Ordenada al origen) de valor -68.92 Kg, es el peso esperado o promedio de un individuo de genero femenino que tiene cero altura, edad, actividad física y consumo diario de alcohol. Esto no es interpretable, ya que una persona tiene que tener una altura superior a cero y no puede tener un peso negativo, pero si podría no realizar actividad física ni consumir alcohol.
El coeficiente \(\hat{\beta_1}\) de valor 653 gramos, corresponde a la altura del individuo. Este coeficiente indica que dada una edad, genero, consumo de alcohol diario y días de actividad física semanal fijos, cada incremento en 1 cm adicional en la altura del individuo implica un aumento de su peso esperado o promedio de 653 gramos.
El coeficiente \(\hat{\beta_2}\) de valor 1.378 kg, corresponde a la edad del individuo. Este coeficiente indica que dada una altura, genero, días de actividad física y consumo de alcohol diario fijos, cada vez que el individuo cumple un año su peso esperado o promedio aumenta en 1.378 kg.
El coeficiente \(\hat{\beta_3}\) de valor 1.224 kg, corresponde a los individuos de genero masculinos. Este coeficiente indica que dada una altura, edad, consumo de alcohol diario y días de actividad física semanal fijos, el peso promedio o esperado para el genero masculino es 1.224 kg mayor al peso femenino (categoría basal). Por otro lado, el coeficientes no indica cunado mas alto es el peso del genero masculino respecto del femenino al fijar los demás coeficientes.
El coeficiente \(\hat{\beta_4}\) de valor 99.1 gramos, corresponde a los días de actividad física semanal que realiza el individuo. Este coeficiente indica que dada una altura, edad, genero y consumo de alcohol diario, cada vez que un individuo realiza un día mas de actividad física semanal su peso esperado o promedio disminuye en 99.1 gramos.
El coeficiente \(\hat{\beta_5}\) de valor -8 gramos, corresponde al nivel de consumo diario de alcohol del individuo. Este coeficiente indica que dada una altura, edad, genero y días de actividad física semanal fijos, cada vez que el individuo consume un trago de alcohol su peso esperado o promedio disminuye en 8 gramos. A simple vista podrá no llegar a tener sentido, ya que a mayor consumo de alcohol el peso debería aumentar, ya sea por el peso del propio liquido como el peso equivalente en grasas. Entiendo que puede tener un relación con los rangos de edades de los individuos que mas consumen alcohol (12 q 17 años), ya que estos se encuentran en pleno crecimiento.
Para determina si los coeficientes son aptos para explicar el peso de un individuo se realiza un \({T}\) test para cada coeficiente en el cual se evalúan las siguientes hipótesis:
Si \({\beta_i \neq 0}\) podemos decir que existe una diferencia estadisticamente significativas del cero para coeficiente \({\beta_i}\), y por lo tanto el coeficiente \({\beta_i}\) explicar la variable \({y}\) (Peso en nuestro caso).
Luego analizando la salida de coefficients_summary concluimos que:
Para determinar si es modelo es significativo para explicar el peso de un individuo se realiza un \(F\) test con las siguientes hipótesis:
Donde: * \(H_0\) afirma que no hay vinculo entre la variable \({y}\)(Peso) y las variables regresoras. * \(H_1\) afirma que al menos una de las variables regresoras sirve para predecir la variable \({y}\) (Peso).
Veamos los resultados el \(F\) test:
glance(model_1)
Podemos apreciar que el \(p-valor < 0.05\) e igual a 0. Con mucha certeza podemos decir que al menos una de las variables regresoras permite explicar el peso. Esto concuerda con los resultados de los \(T\) test para las los coeficientes correspondientes a altura, edad y genero femenino(basa) y masculino).
Según el valor de \(R^2\) ajustado (adj.r.squared), este modelo llega a explica el 35% de la variabilidad del dataset de entrenamiento, lo cual no es un valor bajo pero tampoco es despreciable.
train_set_genero <- data.frame(train_set)
train_set_genero$genero <- factor(
train_set_genero$genero,
levels=c('Masculino', 'Femenino'),
ordered=FALSE
)
table(train_set_genero$genero)
Masculino Femenino
3260 3764
model_genero <- lm(
peso ~ altura + edad + genero + dias_actividad_fisica_semanal + consumo_diario_alcohol,
data = train_set_genero
)
coefficients_summary(model_genero)
_________________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
=========================================================================================================
(Intercept) -67.660044511 2.44965480 -27.6202364 1.682519e-159 -72.4621079 -62.85798114
altura 0.650606544 0.01437975 45.2446353 0.000000e+00 0.6224179 0.67879520
edad 1.406727060 0.09385081 14.9889709 5.121599e-50 1.2227511 1.59070300
generoFemenino -1.262643558 0.27282821 -4.6279802 3.758831e-06 -1.7974693 -0.72781785
dias_actividad_fisica_semanal -0.087391031 0.04992917 -1.7503000 8.011025e-02 -0.1852673 0.01048523
consumo_diario_alcohol 0.007271379 0.06138558 0.1184542 9.057112e-01 -0.1130629 0.12760566
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
____________________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
============================================================================
(Intercept) -67.660044511 Si No
altura 0.650606544 Si No
edad 1.406727060 Si No
generoFemenino -1.262643558 Si No
dias_actividad_fisica_semanal -0.087391031 No Si
consumo_diario_alcohol 0.007271379 No Si
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
glance(model_genero)
Observaciones
género y la edad, en lugar de actividad física y consumo de alcohol. Además se pide explicitamente que la categoría “No comí comida salada o snacks en los últimos 7 días” de la variable consumo_semanal_snacks se encuentre como nivel/categoría basal.
\(E(peso) = \beta_0 + \beta_1 * altura + \beta_2 * edad + \beta_3 * genero + \beta4 * consumoSemanalSnacks + \beta_5 * genero * edad\)
Primero validamos que las primeras categorías en cada variable de tipo factor sean las correctas, ya que esta sera la que el modelo defina como categoría basal:
table(train_set$consumo_semanal_snacks)
0 <=3 4-6 7 14 21 >=28
2162 3144 623 604 231 100 134
table(train_set$genero)
Femenino Masculino
3764 3260
Se puede apreciar que la primeras categorías corresponden a 0 consumo de snacks semanal y genero femenino. Por otro lado la categoría genero se encuentra balanceada.
Modelo 2
Definimos el nuevo modelo:
model_2 <- lm(
peso ~ altura + edad + genero + consumo_semanal_snacks + genero * edad,
data = train_set
)
consumo_semanal_snacks y genero * edad? ¿Son significativas?
coefficients_summary(model_2)
_____________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
=====================================================================================================
(Intercept) -65.56456109 2.82343748 -23.22153813 5.697145e-115 -71.09935565 -60.02976652
altura 0.64312289 0.01457345 44.12974931 0.000000e+00 0.61455449 0.67169128
edad 1.22539002 0.12134815 10.09813515 8.197651e-24 0.98751081 1.46326923
generoMasculino -4.60464631 2.68577421 -1.71445771 8.648904e-02 -9.86957909 0.66028646
consumo_semanal_snacks.L -1.20550502 0.64487036 -1.86937577 6.161235e-02 -2.46964668 0.05863664
consumo_semanal_snacks.Q -0.03462407 0.56980433 -0.06076485 9.515482e-01 -1.15161353 1.08236539
consumo_semanal_snacks.C -1.55903482 0.62845595 -2.48073841 1.313442e-02 -2.79099926 -0.32707037
consumo_semanal_snacks^4 0.29624085 0.63955326 0.46319965 6.432357e-01 -0.95747770 1.54995939
consumo_semanal_snacks^5 0.32794577 0.61234388 0.53555818 5.922810e-01 -0.87243411 1.52832566
consumo_semanal_snacks^6 -0.82570831 0.50219366 -1.64420297 1.001793e-01 -1.81016033 0.15874371
edad:generoMasculino 0.38927567 0.17949126 2.16877226 3.013360e-02 0.03741831 0.74113303
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
______________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
======================================================================
(Intercept) -65.56456109 Si No
altura 0.64312289 Si No
edad 1.22539002 Si No
generoMasculino -4.60464631 No Si
consumo_semanal_snacks.L -1.20550502 No Si
consumo_semanal_snacks.Q -0.03462407 No Si
consumo_semanal_snacks.C -1.55903482 Si No
consumo_semanal_snacks^4 0.29624085 No Si
consumo_semanal_snacks^5 0.32794577 No Si
consumo_semanal_snacks^6 -0.82570831 No Si
edad:generoMasculino 0.38927567 Si No
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Si interpretamos los coeficientes que son significativos para el \(T\) test:
Si fijamos los coeficientes correspondientes a la altura, edad, generoMasculino y generoMasculino*edad; el peso promedio o esperado de un individuo de consume snacks hasta 3 veces por semana es 1.43 kg menor que aquellos que no consumen snacks.
Dado el modelo original:
\(E(peso) = \beta_0 + \beta_1 * altura + \beta_2 * edad + \beta_3 * genero + \ \beta4 * consumoSemanalSnacks + \beta_5 * genero * edad\)
y sabiendo que el genero femenino toma el valor 0 y masculino 1. Si reemplazamos estos valores en el modelo original encontramos que:
\(E_f(peso) = \beta_0 + \beta_1 * altura + \beta_2 * edad + \beta_4 * consumoSemanalSnacks\)
El genero femenino tiene la ordenada \(\beta0\) y las pendientes determinada por \(\beta_1\), \(\beta_2\) y \(\beta_4\).
\(E_m(peso) = (\beta_0 + \beta_3) + \beta_1 \* altura + (\beta_2 + \beta_2,3) * edad + \ \beta_4 * consumoSemanalSnacks\)
El genero masculino tiene una ordenada que es la suma de la ordenada del genero femenino \(\beta_0\) mas \(\beta_3\). Luego cambia la pendiente \(\beta_2\) de la edad, a la cual se le suma \(\beta_2,3\)
Luego, sabiendo que solo cambian los coeficientes correspondientes al genero y edad, si mantenemos contantes los demás coeficientes obtenemos:
Ahora reemplazamos por los coeficientes por lo valores que encontró el modelo:
Femenino:
Masculino:
Finalmente, graficamos ambas rectas definiendo la \(cte\) con un valor que de pesos positivos para tener una gráfica consistente:
cte = 100
train_set %>%
mutate(
peso = ifelse(
genero=='Femenino',
(-65.56456109 + 1.22539002 * edad) + cte,
(-70.1692074 + 1.61466569 * edad) + cte
)
) %>%
ggplot(aes(x = edad, y = peso, colour=genero)) +
geom_line() +
ylab('Peso') +
xlab('Edad')
Finalmente, se puede apreciar que las ordenadas de ambos géneros son distintas, donde el genero femenino inicia desde un peso menor al masculino. Luego si variamos únicamente la edad, se aprecia que el peso del genero masculino es mayor al femenino para la misma edad en todo los casos. Esto se debe a que la resta correspondiente al genero masculina esta por arriba de la resta correspondiente al genero femenino.
no significativas de la variable consumo_semanal_snacks evaluar si la variable es significativa en su conjunto y, en caso afirmativo, proponer una redefinición de las mismas que permita obtener una mayor proporción de categorías significativas individualmente. Luego, analizar si existen cambios en la variabilidad explicada por el modelo.
Viendo el resultado de coefficients_summary se aprecia que las siguientes categorías de consumo_semanal_snacks no son significativas:
Pero si son significativas los extremos:
A continuación se realiza un \(F\) test para evaluar la significatividad conjunta de las categóricas de la variable consumo_semanal_snacks para explicar el peso.
El \(F\) test también llamando ANOVA (Análisis de la varianza) se realiza para probar la significatividad conjunta de todos los valores de una variable categórica.
Las hipótesis son las siguientes:
Luego si todos los coeficientes asociados a los valores de variable categórica son cero, se rechaza la hipótesis nula y por lo tanto la variable no es significartiva para explicar el peso en nuestro caso.
A continuación veremos el p-valor resultado de aplicar \(F\) test para cada variable del modelo:
anova_summary(model_2)
Podemos apreciar que el \(p-value < 0.005\) para la variable consumo_semanal_snacks. Por lo tanto se rechaza la hipótesis nula y podemos decir en su conjunto resulta estadísticamente significativa para explicar el peso. Luego, como la variable consumo_semanal_snacks es significativa vale la pena re-definirla. Por otro lado, la combinación de variables genero-edad no es estadísticamente significativa para explicar el peso, pero si lo es el genero en forma separada. Finalmente, como ya vimos en pasos anteriores, edad y altura son significativas.
Modelo 2: Redefinición 1
Dado que no todas las categorías de la variable consumo_semanal_snacks sin significativas a continuación se propone una re-definición de sus categorías que hace que todas ellas sean significativas para el modelo 2.
train_set_snack_1 <- train_set %>% mutate(consumo_semanal_snacks = case_when(
consumo_semanal_snacks %in% c('<=3', '4-6' , '7') ~ '<=7',
consumo_semanal_snacks %in% c('14', '21', '>=28') ~ '>=14',
TRUE ~ as.character(consumo_semanal_snacks)
))
train_set_snack_1$consumo_semanal_snacks <- factor(
train_set_snack_1$consumo_semanal_snacks,
levels=c('0', '<=7', '>=14'),
ordered=FALSE
)
table(train_set_snack_1$consumo_semanal_snacks)
0 <=7 >=14
2162 4371 465
model_2_redefinicion_1 <- lm(
peso ~ altura + edad + genero + consumo_semanal_snacks + genero * edad,
data = train_set_snack_1
)
coefficients_summary(model_2_redefinicion_1)
___________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
===================================================================================================
(Intercept) -64.0389167 2.83445628 -22.593016 3.806812e-109 -69.59531089 -58.4825225
altura 0.6419791 0.01456558 44.075074 0.000000e+00 0.61342615 0.6705321
edad 1.2234673 0.12139076 10.078752 9.956603e-24 0.98550459 1.4614300
generoMasculino -4.6552035 2.68449385 -1.734108 8.294292e-02 -9.91762586 0.6072189
consumo_semanal_snacks<=7 -1.3800004 0.26062486 -5.294968 1.226632e-07 -1.89090421 -0.8690966
consumo_semanal_snacks>=14 -1.5602043 0.50675759 -3.078798 2.086432e-03 -2.55360293 -0.5668057
edad:generoMasculino 0.3928142 0.17941300 2.189441 2.859775e-02 0.04111025 0.7445181
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
_______________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
=======================================================================
(Intercept) -64.0389167 Si No
altura 0.6419791 Si No
edad 1.2234673 Si No
generoMasculino -4.6552035 No Si
consumo_semanal_snacks<=7 -1.3800004 Si No
consumo_semanal_snacks>=14 -1.5602043 Si No
edad:generoMasculino 0.3928142 Si No
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
anova_summary(model_2_redefinicion_1)
glance(model_2_redefinicion_1)
Modelo 2: Redefinición 2
En este caso se propone calcular la media del ratio altura/edad para cada categoría de la variables consumo_semanal_snacks. Luego calculamos los cuantiles de esta nueva distribución y los utilizamos para crear una nueva categorización: los individuos que tenga un ratio menor al cuantil 2 tendran el valor Bajo y Alto en caso contrario. Se intento llevar a mas niveles pero el test \(T\) no daba significativo para todos los coeficientes del modelo 2.
train_set_snack_2 <- train_set %>%
mutate(alt_edad_ratio = round(altura/edad, 0))
avg_train_set_snack_2 <- train_set_snack_2 %>%
group_by(consumo_semanal_snacks) %>%
summarise(avg_alt_edad_ratio = mean(alt_edad_ratio))
ggplot(data = avg_train_set_snack_2, aes(x = avg_alt_edad_ratio)) +
geom_boxplot(alpha = 0.75, fill="blue") +
theme_bw()
Se los siguientes cuantiles utilizaremos el cuantil 2(50%):
quantiles_avg_alt_edad_ratio <- quantile(avg_train_set_snack_2$avg_alt_edad_ratio)
quantiles_avg_alt_edad_ratio
0% 25% 50% 75% 100%
10.73077 10.89892 10.97694 11.03058 11.09952
q2 <- quantiles_avg_alt_edad_ratio[3]
snack_level_mapping <- avg_train_set_snack_2 %>%
mutate(level = case_when(
avg_alt_edad_ratio < q2 ~ 'Bajo',
avg_alt_edad_ratio >= q2 ~ 'Alto'
)) %>% select(consumo_semanal_snacks, level)
snack_level_mapping %>%
arrange(consumo_semanal_snacks)
train_set_snack_2 <- train_set %>%
inner_join(snack_level_mapping, by = 'consumo_semanal_snacks') %>%
mutate(consumo_semanal_snacks = level) %>%
select(-level)
test_set_snack_2 <- test_set %>%
inner_join(snack_level_mapping, by = 'consumo_semanal_snacks') %>%
mutate(consumo_semanal_snacks = level) %>%
select(-level)
train_set_snack_2 %>%
group_by(consumo_semanal_snacks) %>%
tally()
test_set_snack_2 %>%
group_by(consumo_semanal_snacks) %>%
tally()
model_2_redefinicion_2 <- lm(
peso ~ altura + edad + genero + consumo_semanal_snacks + genero * edad,
data = train_set_snack_2
)
coefficients_summary(model_2_redefinicion_2)
___________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
===================================================================================================
(Intercept) -65.6507415 2.81532257 -23.319083 6.616674e-116 -71.16962416 -60.1318588
altura 0.6435785 0.01452076 44.321274 0.000000e+00 0.61511347 0.6720436
edad 1.2217889 0.12112912 10.086666 9.183448e-24 0.98433923 1.4592385
generoMasculino -4.6387828 2.67872503 -1.731713 8.336863e-02 -9.88989298 0.6123275
consumo_semanal_snacksBajo 1.1231822 0.24872446 4.515769 6.411838e-06 0.63560713 1.6107573
edad:generoMasculino 0.3929346 0.17903067 2.194789 2.821136e-02 0.04198041 0.7438888
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
_______________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
=======================================================================
(Intercept) -65.6507415 Si No
altura 0.6435785 Si No
edad 1.2217889 Si No
generoMasculino -4.6387828 No Si
consumo_semanal_snacksBajo 1.1231822 Si No
edad:generoMasculino 0.3929346 Si No
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
anova_summary(model_2_redefinicion_2)
glance(model_2_redefinicion_2)
models <- list(
'Modelo 1' = model_1,
'Modelo 2' = model_2,
'Modelo 2 - Re-definición 1' = model_2_redefinicion_1,
'Modelo 2 - Re-definición 2' = model_2_redefinicion_2
)
models %>%
map_df(glance, .id = "model") %>%
arrange(desc(adj.r.squared))
Conclusión: Ambos modelos son significativos para explicar el peso. El modelo Modelo 2 - Re-definición 1 es mas explicativo, ya que \(R^2\) ajustado es mayor. Finamente, ambos modelos son meno explicativos que el modelo original(Modelo 2).
Al continuación se define 2 modelos.
Modelo 4
\(E(peso) = \beta_0 + \beta_1 * altura + \beta_2 * edad + + \beta_3 * genero + \beta4 * consumoSemanalSnacks + \beta_5 * diasActividadFisicaSemanal + \beta_6 * altura * genero\)
Se utilizo la redefinición de la variable consumo_semanal_snacks como base. Ademase se agregar la variable dias_actividad_fisica_semanal entendiendo que tiene una influencia iportante en el peso y luego la asociacion altura * genero ya que en general mas mujeres tienen a ser mas bajar que los varones y vise versa.
model_4 <- lm(
peso~
altura +
edad +
genero +
consumo_semanal_snacks +
dias_actividad_fisica_semanal +
altura*genero,
data = train_set_snack_1
)
coefficients_summary(model_4)
_______________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
=======================================================================================================
(Intercept) -57.13540489 3.66317283 -15.597245 6.119582e-54 -64.3163351 -49.95447466
altura 0.58771694 0.02211420 26.576453 2.445371e-148 0.5443664 0.63106748
edad 1.36070412 0.09229317 14.743281 1.806969e-48 1.1797815 1.54162674
generoMasculino -15.91652545 4.63512139 -3.433896 5.984266e-04 -25.0027698 -6.83028113
consumo_semanal_snacks<=7 -1.38916513 0.26043440 -5.334031 9.906841e-08 -1.8996956 -0.87863468
consumo_semanal_snacks>=14 -1.51577303 0.50629126 -2.993876 2.764223e-03 -2.5082575 -0.52328854
dias_actividad_fisica_semanal -0.09518655 0.04988025 -1.908301 5.639321e-02 -0.1929670 0.00259388
altura:generoMasculino 0.10477118 0.02825811 3.707649 2.108111e-04 0.0493767 0.16016566
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
___________________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
===========================================================================
(Intercept) -57.13540489 Si No
altura 0.58771694 Si No
edad 1.36070412 Si No
generoMasculino -15.91652545 Si No
consumo_semanal_snacks<=7 -1.38916513 Si No
consumo_semanal_snacks>=14 -1.51577303 Si No
dias_actividad_fisica_semanal -0.09518655 No Si
altura:generoMasculino 0.10477118 Si No
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
anova_summary(model_4)
glance(model_4)
train_set3 <- column_mean_quantile_binning(train_set_snack_1, 'dias_actividad_fisica_semanal')
test_set3 <- column_mean_quantile_binning(train_set_snack_1, 'dias_actividad_fisica_semanal')
train_set3 <- column_mean_quantile_binning(train_set3, 'consumo_semanal_frutas')
test_set3 <- column_mean_quantile_binning(test_set3, 'consumo_semanal_frutas')
train_set3 <- column_mean_quantile_binning(train_set3, 'consumo_semanal_verdura')
test_set3 <- column_mean_quantile_binning(test_set3, 'consumo_semanal_verdura')
train_set3 <- column_mean_quantile_binning(train_set3, 'consumo_semanal_comida_grasa')
test_set3 <- column_mean_quantile_binning(test_set3, 'consumo_semanal_comida_grasa')
train_set3 <- column_mean_quantile_binning(train_set3, 'consumo_semanal_gaseosas')
test_set3 <- column_mean_quantile_binning(test_set3, 'consumo_semanal_gaseosas')
segmented_box_plot(
test_set3,
column = 'peso',
segmented_by = 'dias_actividad_fisica_semanal',
title = 'Niveles actividad fisica ordenados por la mediana del peso en Test',
y_label = 'Peso (Kg)',
y_limits = c(40, 100),
x_label = 'Niveles de actividad física (Dias)'
)
Modelo 5
\(E(peso) = \beta_0 + \beta_1 * altura + \beta_2 * edad + + \beta_3 * genero + \beta4 * consumoSemanalSnacks + \\ \beta_5 * diasActividadFisicaSemanal + \beta_6 * consumoSemanalFrutas + \beta_7 * consumoSemanalVerduras + \\* \beta_8 * consumoSemanalGrasas + \beta_9 * consumoSemanalGaseosas\)
Se utilizo la redefinición de la variable consumo_semanal_snacks como base. Ademase se agregar la variable consumo_semenal_frutras/verduras/grasas/gaseaosas entendiendo que también tiene una influencia importante en el peso.
model_5 <- lm(
peso ~
edad +
genero +
altura +
consumo_semanal_snacks +
consumo_semanal_frutas +
consumo_semanal_verdura,
data = train_set3
)
coefficients_summary(model_5)
_____________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
=====================================================================================================
(Intercept) 9.8678389 1.98469390 4.9719702 6.785453e-07 5.9772367 13.75844105
edad 0.5848636 0.06830864 8.5620740 1.348627e-17 0.4509580 0.71876925
generoMasculino 0.0245439 0.19988924 0.1227875 9.022789e-01 -0.3672997 0.41638746
altura 0.3042205 0.01142257 26.6332690 6.171857e-149 0.2818288 0.32661222
consumo_semanal_snacks<=7 -0.8350398 0.19147128 -4.3611750 1.312220e-05 -1.2103815 -0.45969796
consumo_semanal_snacks>=14 -0.7064861 0.37220275 -1.8981216 5.772121e-02 -1.4361164 0.02314422
consumo_semanal_frutasBajo -15.8033155 0.20429808 -77.3542056 0.000000e+00 -16.2038017 -15.40282928
consumo_semanal_verduraBajo NA NA NA NA NA NA
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
________________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
========================================================================
(Intercept) 9.8678389 Si No
edad 0.5848636 Si No
generoMasculino 0.0245439 No Si
altura 0.3042205 Si No
consumo_semanal_snacks<=7 -0.8350398 Si No
consumo_semanal_snacks>=14 -0.7064861 No Si
consumo_semanal_frutasBajo -15.8033155 Si No
consumo_semanal_verduraBajo NA NA NA
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
anova_summary(model_5)
glance(model_5)
c(models, list('Modelo 4'=model_4, 'Modelo 5'=model_5)) %>%
map_df(glance, .id = "model") %>%
arrange(desc(adj.r.squared))
Finalmente, si comparamos los modelos por \(R^2\) Ajustado, se puede apreciar que el modelo 5 (con todas las variables categóricas re-definidas) llega a captar la mayor varianza explicada sobre el dataset de entrenamiento. Por supuesto esto no dice nada acerca de la performance del modelo en test, pero si que tiene la mejor capacidad para extraer información de los dato de entrenamiento.
Ahora comparamos la performance de todo los modelos al evaluar el error delos mismo al predecir el peso en el conjunto de train y test tanto para RMSE como MAE:
RMSE
custom_models_evaluation_summary(
model_1, model_2, model_2_redefinicion_1, model_4, model_5,
test_set, train_set_snack_1, test_set3,
metric_fn = rmse
)
Si utilizamos la métrica RMSE podemos ver que el modelo 5 tiene el menor error en el conjunto de test. Por otro lados el que tiene la mayor diferencia de error entre test y entrenamiento. Esto nos dice que podría estar sobre-ajustandose al conjunto de entrenamiento. El modelo 3 tiene un error en test muy cercano y ademas tiene un diferencia entre test y train mucho menor. por esto ultimo parece ser el mejor modelo ya que tiene prácticamente el menor error posible y también el menor sobre-ajuste al conjunto de entrenamiento.
MAE
custom_models_evaluation_summary(
model_1, model_2, model_2_redefinicion_1, model_4, model_5,
test_set, train_set_snack_1, test_set3,
metric_fn = mae
)
Si medimos a partir del MAE sucede algo muy similar, El modelo 3 es es que tiene menor error y ademas menos sobre-ajuste.
Finalmente, según ambas metricas el moejor modelo es el Modelo 3.
Analizar en profundidad el cumplimiento de los supuestos del modelo lineal para el modelo inicial.
plot(model_1)
Homocedasticidad
Al visualizar el primer gráfico (Residuos vs. Valores ajustados) se puede apreciar que hay presencia de homocedasticidad, ya que a medida que aumentan los valores predichos la variabilidad o amplitud de los residuos parece mantenerse en los mismo niveles. Dadas esta condiciones podemos decir que se cumple el supuesto de varianza constante.
Normalidad
Al visualizar el diagrama QQ-Plot podemos observas que en el extremo derecho, el modelo sobre-estima el peso del los individuos ya que hay una gran diferencia entre los valores predichos y los valores esperados teóricos. Lo contrario sucede a izquierda, donde el modelo subestima el valor de peso en comparación al valor esperado teórico, aunque los valores de los residuos son menores en este caso. Finalmente el QQ-Plot muestra un grado de alejamiento pronunciado de una distribución normal teórica y por lo tanto no se cumple el supuesto de normalidad del modelo.
Apalancamiento (Leverage)
Si observamos el gráfico de Residuos vs Apalacamiento vemos varias observaciones o individuos que se alejan a derecha del cumulo principal. Estos ejercen un alejamiento de las prediciones del modelo vs los valores reales a partir de un apalancamiento(leverage) 0.0025 y es mas pronunciado desde 0.0035. Finalmente, vemos un grado importante de desvió de las predicciones vs valores reales y porn ente un grado importante de apalancamiento(leverage).
A continuación se pueden ver lo individuos que producen mayor apalancamiento(leverage) y por ende sesgo en las predicciones del modelo:
augment(model_1) %>%
filter(.hat>0.0025) %>%
arrange(.hat)
Leer el archivo “encuesta_salud_modelo6.csv”. Este último consiste en el dataset original de train con la incorporación de algunas observaciones adicionales que pueden incluir valores atípicos. En particular, observar la relación entre peso y altura ¿Qué ocurre con estos nuevos datos? Entrenar el modelo inicial con estos nuevos datos y comentar qué se observa en los coeficientes estimados y las métricas de evaluación (R cuadrado ajustado, RMSE y MAE) respecto al modelo entrenado con el set de entrenamiento original. Entrenar un modelo robusto con la misma especificación que el modelo inicial sobre los nuevos datos. Comparar los coeficientes y su performance (RMSE y MAE) respecto al modelo inicial no robusto entrenado en este punto. ¿Qué puede concluir al respecto?
Se carga el conjunto de entrenamiento en crudo,e s decir sin pre-procesamiento. Luego se resumen los valores de las variables categóricas y se eliminan missing values, ya que siguen siendo muy poco casos:
original_train_set <- shorten_values(preprocess(load_original_train_set()))
missings_summary(original_train_set)
new_train_set <- process_missings(original_train_set)
missings_summary(new_train_set)
nrow(original_train_set)
[1] 7060
nrow(new_train_set)
[1] 7060
Comparemos las distribuciones del peso vs altura en ambos conjunto de entrenamiento:
box_plots(
train_set %>% select(peso, altura),
title = 'Comparativas de distribuciones del peso y la altura'
)
box_plots(
new_train_set %>% select(peso, altura),
title = 'Comparativas de distribuciones del peso y la altura'
)
En el dataset de entrenamiento original la variable peso tiene prácticamente el doble de outliers que el dataset procesado.
Modelo 6
Definimos un modelo igual al modelo 1 pero entrenando en el dataset de entrenamiento original.
model_6 <- lm(
peso ~ altura + edad + dias_actividad_fisica_semanal + consumo_diario_alcohol,
data = new_train_set
)
coefficients_summary(model_6)
__________________________________________________________________________________________________________
term estimate std.error statistic p.value conf.low conf.high
==========================================================================================================
(Intercept) -73.226959301 2.64240181 -27.71227259 1.533910e-160 -78.4068604 -68.04705825
altura 0.687757405 0.01534488 44.81998610 0.000000e+00 0.6576768 0.71783798
edad 1.360298885 0.11300763 12.03723087 4.765114e-33 1.1387700 1.58182777
dias_actividad_fisica_semanal -0.095288639 0.06016347 -1.58382891 1.132775e-01 -0.2132271 0.02264982
consumo_diario_alcohol 0.006469476 0.07426869 0.08710906 9.305873e-01 -0.1391195 0.15205841
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
____________________________________________________________________________
Termino Coeficiente Signiticativo IC incluye al cero
============================================================================
(Intercept) -73.226959301 Si No
altura 0.687757405 Si No
edad 1.360298885 Si No
dias_actividad_fisica_semanal -0.095288639 No Si
consumo_diario_alcohol 0.006469476 No Si
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
anova_summary(model_6)
glance(model_6)
print(paste('Disminicion de adj.r.squared:', abs(0.352113 - 0.2734821) * 100, '%'))
[1] "Disminicion de adj.r.squared: 7.86309 %"
Dada la presencia de outliers en la variable peso, el \(R^2\) Ajustado baja con respecto al modelo 1.
models <- list('Modelo 6'=model_6)
models_evaluation_summary(models, train_set, metric_fn = rmse)
models_evaluation_summary(models, train_set, metric_fn = mae)
Por otro lado, aumento el error de predicción tanto en train como en test. Finalmente, el modelo tiene un grado de overfitting mucho mayor que los modelos anteriores, ya que la métrica de evaluación en test y train tiene una diferencia muy pronunciada de 1.7 puntos.
Modelo 7
Definimos un modelo igual al modelo 1 entrenando en el dataset de entrenamiento original y usamos un modelo lineal robusto.
model_7 <- rlm(
peso ~ altura + edad + dias_actividad_fisica_semanal + consumo_diario_alcohol,
data = new_train_set
)
coefficients_summary(model_7)
___________________________________________________________________________________________
term estimate std.error statistic conf.low conf.high
===========================================================================================
(Intercept) -69.48061301 2.01139614 -34.5434753 -73.42287701 -65.53834901
altura 0.66495747 0.01168052 56.9287383 0.64206407 0.68785088
edad 1.26361070 0.08602140 14.6894924 1.09501186 1.43220955
dias_actividad_fisica_semanal -0.01588531 0.04579643 -0.3468679 -0.10564466 0.07387404
consumo_diario_alcohol 0.03260215 0.05653332 0.5766891 -0.07820113 0.14340542
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
[1] "WARN: p.value column is required to make model coefficients summary!\n"
[1] "WARN: p.value column is required to plot tidy coefficients!\n"
NULL
anova_summary(model_7)
models <- list('Modelo 6'=model_6, 'Modelo 7'=model_7)
models_evaluation_summary(models, test_set, metric_fn = rmse)
models_evaluation_summary(models, test_set, metric_fn = mae)
El modelo lineal robusto (Modelo 7) parece tener un menor error de entrenamiento muy cercano al modelo 6, pero tiene mayor sobre- ajuste que el modelo 6, aunque es una diferencia muy baja.
Dado esto, seria una buena selecciono elegir el modelo 7, ya que el sobre ajuste practicamente no cambia y obtenemos un error de predicción en test ligeramente menor.